home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / gen-code.em < prev    next >
Lisp/Scheme  |  1993-07-12  |  44KB  |  1,373 lines
  1. ;; Eulisp Module
  2. ;; Author: pete broadbery
  3. ;; File: gen-code.em
  4. ;; Date: 30/jul/1991
  5. ;;
  6. ;; Project:
  7. ;; Description:
  8. ;;  code generator pass of compiler.
  9. ;;  assume names pass is complete.
  10. ;;
  11.  
  12. (defmodule gen-code
  13.   ((except (fold) standard)
  14.    list-fns
  15.  
  16.    syntx-utl
  17.    props;; Should try to avoid this --- maybe an analysis module?
  18.    syntx-env;; Should try to avoid this --- maybe an analysis module?
  19.    generate
  20.    pass
  21.    ;; use Should try to avoid this --- maybe an analysis module?
  22.  
  23.    rshow
  24.    stop
  25.    gen-docs
  26.    )
  27.   ()
  28.  
  29.   (defcondition Compile-Time-Error ()
  30.     msg "" values ())
  31.   (export Compile-Time-Error)
  32.  
  33.   (export generate-code)
  34.  
  35.   (deflocal *last* ())
  36.   (deflocal lastobj ())
  37.   (defun code-gen (thing state)
  38.     (let ((prev *last*))
  39.       (setq *last* state)
  40.       (setq lastobj thing)
  41.       ;;(format t "(Generating code for: ~a~%state: ~a" thing state)
  42.       ;;(print-props thing)
  43.       (let ((xx (generic-code-gen thing state)))
  44.     (setq *last* prev)
  45.     ;;(format t ")~%" xx)
  46.     xx)))
  47.  
  48.   (defun last ()
  49.     *last*)
  50.   (export last)
  51.  
  52.   (defun generate-code (module)
  53.     (initialize-docs (module-name module))
  54.     (let ((final-state
  55.        (code-gen module
  56.              (make-initial-compiler-state module))))
  57.       (complete-docs)
  58.       (modify-compiler-state
  59.        final-state
  60.        'state-code
  61.        (add-code-vectors (list (reify-code-stream
  62.                 (complete-installation module final-state)))
  63.              final-state)
  64.        ;; blast the old stream
  65.        'state-stream (make-new-code-stream))))
  66.  
  67.   (defconstant generic-code-gen (make-compiler-pass 'code-gen))
  68.  
  69.   (defmethod generic-code-gen ((seq sequence) state)
  70.     (let ((newstate (fold (lambda (obj state)
  71.                 (do-pop 1 (code-gen obj state)))
  72.               (sequence-body seq)
  73.               state)))
  74.       (code-gen (sequence-end seq) newstate)))
  75.  
  76.  
  77.   (defun make-initial-compiler-state (module)
  78.     (make-compiler-state (make-new-code-stream)
  79.              (make-stack)
  80.              (make-static-store)
  81.              (make-code-list)))
  82.  
  83.   (defun complete-installation (mod state)
  84.     state)
  85.  
  86.   ;; Modules. Unfortunately they have a closure...
  87.   ;; Makes them easy to init though
  88.   (defmethod generic-code-gen ((mod module-block) state)
  89.     (let ((env (make-lambda-environment mod)))
  90.       ;; Idea is to make a nice, clean easy to call
  91.       ;; function...
  92.       ((setter real-lambda-env) mod env)
  93.       (do-code-sequence
  94.        (list (lambda (state)
  95.            (modify-compiler-state
  96.         state
  97.         'state-stack (stack-push (state-stack state) nil)))
  98.          (lambda (state)
  99.            (do-alloc-env env state))
  100.          (lambda (state)
  101.            (code-gen (module-body mod) state))
  102.          ;; the return from progn, and throw the env away
  103.          (lambda (state)
  104.            (do-pop 2 state))
  105.          (lambda (state)
  106.            (do-push-static t state)) ;; hack
  107.            (lambda (state)
  108.          (do-return state)))
  109.        state)))
  110.  
  111.   (defmethod generic-code-gen ((cd condition-term) state)
  112.     (let ((lab1 (make-label state))
  113.       (lab2 (make-label state)))
  114.       (let ((stack (state-stack state)))
  115.     (cond
  116.      ;; can we get away with losing a 'not'
  117.      ;;((negation-p (cond-test cd))
  118.      ;;(gen-code (wind-negation cd) state))
  119.      ;; test for spectacularly dumb conditions...
  120.      ((literal-p (cond-test cd))
  121.       (if (null (literal-content (cond-test cd)))
  122.           (code-gen (cond-f-part cd) state)
  123.         (code-gen (cond-t-part cd) state)))
  124.      ((term-tail-call cd)
  125.       (do-code-sequence
  126.        (list (lambda (state) (code-gen (cond-test cd) state))
  127.          (lambda (state) (do-branch-on-nil lab1 state))
  128.          (lambda (state) (code-gen (cond-t-part cd) state))
  129.          (lambda (state) (modify-compiler-state
  130.                   state
  131.                   'state-stack stack))
  132.          (lambda (state) (do-add-label lab1 state))
  133.          (lambda (state) (code-gen (cond-f-part cd) state)))
  134.        state))
  135.      (t (do-code-sequence
  136.          (list (lambda (state) (code-gen (cond-test cd) state))
  137.            (lambda (state) (do-branch-on-nil lab1 state))
  138.            (lambda (state) (code-gen (cond-t-part cd) state))
  139.            (lambda (state) (do-branch lab2 state))
  140.            ;; Should unscrew state here...
  141.            ;; Hopefully only stack in wrong
  142.            (lambda (state)
  143.              (modify-compiler-state
  144.               state
  145.               'state-stack stack))
  146.            (lambda (state)
  147.              (do-add-label lab1 state))
  148.            (lambda (state)
  149.              (code-gen (cond-f-part cd) state))
  150.            (lambda (state)
  151.              (do-add-label lab2 state)))
  152.          state))))))
  153.  
  154.  
  155.   (defmethod generic-code-gen ((id ident-term) state)
  156.     ;; maybe ought to take a quick look at the stack here...
  157.     (let ((state (value-ref (ident-decl id) (ident-block id) id state)))
  158.       (if (term-tail-call id)
  159.       (add-tidy-code (enclosing-lambda id) state)
  160.     state)))
  161.  
  162.   (defgeneric value-ref (id loc orig state))
  163.  
  164.   (defmethod value-ref ((x <object>) loc id state)
  165.     (do-push-global 'some-value state))
  166.  
  167.   (defmethod value-ref ((x module-definition) loc id state)
  168.     (local-module-ref x state))
  169.  
  170.   (defmethod value-ref ((x definition) loc id state)
  171.     (if (binding-closed x)
  172.     ;; Generate env. ref
  173.     (closed-value-ref x loc id state)
  174.       (open-value-ref x loc state)))
  175.  
  176.   (defmethod value-ref ((x imported-definition) loc id state)
  177.     (do-push-global (external-name x)
  178.             state))
  179.  
  180.   (defmethod value-ref ((x lambda-id) loc id state)
  181.     (if (binding-closed x)
  182.     ;; Generate env. ref
  183.     (closed-value-ref x loc id state)
  184.       (open-value-ref x loc state)))
  185.  
  186.   ;; Ahrrhgg. Assignments
  187.   (defmethod generic-code-gen ((x assignment-term) state)
  188.     (let ((id (assign-var x)))
  189.       (let* ((state (code-gen (assign-body x) state))
  190.          (state2 (set-value-ref (ident-decl id) (ident-block id) id state)))
  191.     (if (term-tail-call x)
  192.         (add-tidy-code (enclosing-lambda x) state2)
  193.       state2))))
  194.  
  195.  
  196.   (defgeneric set-value-ref (id loc orig state))
  197.  
  198.   (defmethod set-value-ref ((x <object>) loc id state)
  199.     (do-global-set 'some-value state))
  200.  
  201.   (defmethod set-value-ref ((x module-definition) loc id state)
  202.     (set-local-module-ref x state))
  203.  
  204.   (defmethod set-value-ref ((x definition) loc id state)
  205.     (if (binding-closed x)
  206.     ;; Generate env. ref
  207.     (set-closed-value-ref x loc id state)
  208.       (set-open-value-ref x loc state)))
  209.  
  210.   (defmethod set-value-ref ((x lambda-id) loc id state)
  211.     (prog1 (if (binding-closed x)
  212.            ;; Generate env. ref
  213.            (set-closed-value-ref x loc id state)
  214.          (set-open-value-ref x loc state))
  215.       nil))
  216.  
  217.   ;; here?
  218.   (defun find-env-depth (env target)
  219.     (if (null env)
  220.     (format t "Could not env ~a in ~a~%" env target)
  221.       (cond ((eq env target)
  222.          0)
  223.         ((= (env-object-size env) 0)
  224.          (find-env-depth (env-object-prev env) target))
  225.         (t
  226.          (+ (find-env-depth (env-object-prev env) target) 1)))))
  227.  
  228.   (defun open-value-ref (x loc state)
  229.     (do-stack-ref (scanq-stack (state-stack state) x)
  230.           state))
  231.  
  232.   (defun local-module-ref (x state)
  233.     (let ((xx (do-push-global (external-name x) state)))
  234.       xx))
  235.  
  236.  
  237.   (defun closed-value-ref (binding loc id state)
  238.     (let ((env (stacked-lambda-env (enclosing-lambda id)))
  239.       (posn (binding-posn binding))
  240.       (def-env (lambda-env (enclosing-lambda binding))))
  241.       ;;(stop (list env posn def-env))
  242.       (let ((depth (find-env-depth env def-env)))
  243.     (do-code-sequence
  244.      (list (lambda (state) (do-stack-ref (scanq-stack (state-stack state) env) state))
  245.            (lambda (state) (do-env-ref depth posn state)))
  246.      state))))
  247.  
  248.   (defun set-open-value-ref (x loc state)
  249.     (let ((state (do-stack-ref 0 state)))
  250.       (do-set-stack-ref (scanq-stack (state-stack state) x)
  251.             state)))
  252.  
  253.   (defun set-local-module-ref (x state)
  254.     (do-code-sequence
  255.      (list (lambda (state)
  256.          (do-stack-ref 0 state))
  257.        (lambda (state)
  258.          (do-global-set (external-name x) state)))
  259.      state))
  260.  
  261.   (defun set-closed-value-ref (binding loc id state)
  262.     (let ((env (stacked-lambda-env (enclosing-lambda id)))
  263.       (posn (binding-posn binding))
  264.       (def-env (lambda-env (enclosing-lambda binding))))
  265.       ;;(format t "set-closed-ref: ~a ~a ~a ~a~%" env def-env posn)
  266.       ;;(stop (list env posn def-env))
  267.       (let ((depth (find-env-depth env def-env)))
  268.     (do-code-sequence
  269.      (list (lambda (state) (do-stack-ref (scanq-stack (state-stack state) env) state))
  270.            (lambda (state)
  271.          (do-stack-ref 1 state))
  272.            (lambda (state)
  273.          (do-setter-env-ref depth posn state))
  274.            (lambda (state)
  275.          (do-pop 1 state)))
  276.      state))))
  277.  
  278.   ;;
  279.   ;;; this-context: grab this function from the stack
  280.   ;;
  281.  
  282.   (defmethod generic-code-gen ((ob special-term) state)
  283.     (cond ((eq (special-term-name ob) 'call-next-method-internal)
  284.        (do-code-sequence
  285.         (list (lambda (state)
  286.             (do-stack-ref (+ (stack-depth (state-stack state)) 0) state))
  287.           ;; check here not needed --- apply methods ought to check though
  288.           (lambda (state)
  289.             (do-cdr state)))
  290.         state))
  291.       ((eq (special-term-name ob) 'inline-fn)
  292.        ;;(format t "In special ~a~%" ob)
  293.        (make-inline-lambda (special-term-data ob) state))
  294.       ((eq (special-term-name ob) 'add-property)
  295.        (let ((val (ident-decl (car (special-term-objects ob)))))
  296.          (add-defn-prop val (car (special-term-data ob)) (cadr (special-term-data ob))))
  297.        (do-push-static nil state))
  298.       ((eq (special-term-name ob) 'add-callback)
  299.        (let ((val (ident-decl (car (special-term-objects ob)))))
  300.          (add-defn-prop val 'callbacks (list (car (special-term-data ob)))))
  301.        (do-push-static nil state))
  302.       (t (format t "Unknown special")
  303.          state)))
  304.  
  305.   (defun make-inline-lambda (args state)
  306.     (let ((ns (modify-compiler-state state
  307.                      'state-stack (stack-push
  308.                            (stack-push
  309.                             (stack-push
  310.                              (stack-push 
  311.                               (stack-push
  312.                                (make-stack) 'a) 'b) 'c) 'd) 'e)
  313.                      'state-stream (make-new-code-stream)
  314.                      'state-statics (state-statics state)
  315.                      'state-code (make-code-list)))
  316.       (init-label (make-label state)))
  317.       (let ((inlined-state (let* ((state (do-add-label init-label ns))
  318.                   (state (do-pop 1 state))
  319.                   (state (do-inline-code (cdr args) (abs (car args)) state))
  320.                   (state (do-return state)))
  321.                  state)))
  322.     (let ((new-state (modify-compiler-state
  323.                          state
  324.                          'state-code
  325.                          (add-code-vectors (cons (reify-code-stream inlined-state)
  326.                          nil)
  327.                                            state))))
  328.       (let* ((state (do-push-label init-label new-state))
  329.          (state (do-push-static nil state))
  330.          (state (do-allocate-closure (if (< (car args) 0)
  331.                          (cons t (- (car args)))
  332.                            (cons nil (car args)))
  333.                          nil ;; nobody documents these things -- right..
  334.                          state)))
  335.         state)))))
  336.  
  337.   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  338.   ;; Function Applications
  339.   ;;
  340.   ;;
  341.  
  342.   (deflocal this-applic)
  343.  
  344.   (defmethod generic-code-gen ((applic applic-term) state)
  345.     (let ((obj (find-fn (applic-fun applic)))
  346.       (tail-flag (term-tail-call applic)))
  347.       (setq this-applic (cons obj applic))
  348.       (check-arguments applic obj)
  349.       ;; do any strange side effect type stuff specified by obj
  350.       (do-callbacks (function-fn obj) applic)
  351.       ((find-app-fn (function-type obj)) obj applic tail-flag state)))
  352.  
  353.  
  354.   (defun check-arguments (applic obj)
  355.     (let ((nargs (list-length (applic-args applic)))
  356.       (reqd-nargs (function-nargs obj)))
  357.       (if (or (eq (function-type obj) 'unknown)
  358.           (= (cdr reqd-nargs) 9999)
  359.           (= nargs (cdr reqd-nargs))
  360.           (and (car reqd-nargs)
  361.            (>= (+ nargs 1) (cdr reqd-nargs))))
  362.       t
  363.     (error "Function called with wrong number of args"
  364.         Compile-Time-Error
  365.         'values (list reqd-nargs applic)
  366.         'msg "Function called with wrong number of args (should be ~a): ~%~a~%"))))
  367.  
  368.   (defconstant find-callback (mk-finder))
  369.  
  370.   (defgeneric do-callbacks (obj applic)
  371.     methods ((((x abs-definition) applic)
  372.           (labels ((do-callback (l)
  373.                     (cond ((null l) nil)
  374.                       (t ((find-callback (car l)) applic)
  375.                          (do-callback (cdr l))))))
  376.               (do-callback (defn-prop-ref x 'callbacks))))
  377.          (((x syntax-obj) y)
  378.           nil)))
  379.  
  380.   ((setter find-callback) 'setter-setter-function
  381.    (lambda (applic)
  382.      ;;(format t "set-setter: ~a~%" applic)
  383.      (if (not (ident-p (cadr (applic-args applic))))
  384.      nil
  385.        ((setter decl-setter)
  386.     (ident-decl (car (applic-args applic)))
  387.     (ident-decl (cadr (applic-args applic)))))))
  388.  
  389.   (defconstant find-app-fn (mk-finder))
  390.  
  391.   ;; local function. Called with branch
  392.   (defun apply-local-function (obj applic tail state)
  393.     (let ((branch-lab (read-init-label (defn-body (function-fn obj))) state))
  394.       (if tail
  395.       (do-branch branch-lab
  396.              (push-local-env (defn-body (function-fn obj))
  397.                      (tail-prepare-args obj applic state)))
  398.     (let ((ret-lab (make-label nil)))
  399.       (do-code-sequence
  400.        (list (lambda (state)
  401.           (std-prepare-args obj applic state ret-lab))
  402.          (lambda (state)
  403.            (push-local-env (defn-body (function-fn obj)) state))
  404.          (lambda (state)
  405.            (do-branch branch-lab state))
  406.          (lambda (state)
  407.            (do-add-label ret-lab state))
  408.          (lambda (state)
  409.            (correct-stack applic obj state)))
  410.        state)))))
  411.  
  412.   (defun apply-nonlocal-function (obj applic tail state)
  413.     (if tail
  414.     (do-apply-bvf (mk-calltype applic obj)
  415.               (tail-prepare-args obj applic state))
  416.       (let ((ret-lab (make-label nil)))
  417.     (do-code-sequence
  418.      (list (lambda (state)
  419.          (std-prepare-args obj applic state ret-lab))
  420.            (lambda (state)
  421.          (do-apply-bvf (mk-calltype applic obj) state))
  422.            (lambda (state)
  423.          (do-add-label ret-lab state))
  424.            (lambda (state)
  425.          (correct-stack applic obj state)))
  426.      state))))
  427.  
  428.   (defun apply-unknown-function (obj applic tail state)
  429.     (if tail
  430.     (do-apply-any (mk-calltype applic obj)
  431.               (tail-prepare-args obj applic state))
  432.       (let ((ret-lab (make-label nil)))
  433.     (do-code-sequence
  434.      (list (lambda (state)
  435.          (std-prepare-args obj applic state ret-lab))
  436.            (lambda (state)
  437.          (do-apply-any (mk-calltype applic obj) state))
  438.            (lambda (state)
  439.          (do-add-label ret-lab state))
  440.            (lambda (state)
  441.          (correct-stack applic obj state)))
  442.      state))))
  443.  
  444.   ;;(defun apply-c-function (obj applic tail state)
  445.   ;; (if tail
  446.   ;;    (do-apply-cfn (mk-calltype applic obj)
  447.   ;;              (tail-prepare-args obj applic state))
  448.   ;;  (let ((ret-lab (make-label nil)))
  449.   ;;    (do-code-sequence
  450.   ;;     (list (lambda (state)
  451.   ;;         (std-prepare-args obj applic state ret-lab))
  452.   ;;           (lambda (state)
  453.   ;;         (do-apply-cfn (mk-calltype applic obj) state))
  454.   ;;           (lambda (state)
  455.   ;;         (do-add-label ret-lab state))
  456.   ;;           (lambda (state)
  457.   ;;         (correct-stack applic obj state)))
  458.   ;;     state))))
  459.   
  460.   (defun apply-c-function (obj applic tail state)
  461.     ;;(format t "[In C-fn: ~a~%~a~%" state applic)
  462.     (if tail 
  463.     (let* ((state (code-gen (applic-fun applic) state))
  464.            (state (push-args (applic-args applic) obj state))
  465.            (state (do-slide (stack-depth (state-stack state))
  466.                 (+ (actual-args applic obj) 1)
  467.                 state))
  468.            (state (do-apply-cfn (mk-calltype applic obj) state))
  469.            ;; should tidy the stack..
  470.            (state (do-return state)))
  471.       ;;(format t "Out: ~a]~%" state)
  472.       state)
  473.       (let* ((state (code-gen (applic-fun applic) state))
  474.          (state (push-args (applic-args applic) obj state))
  475.          (state (do-apply-cfn (mk-calltype applic obj) state))
  476.          (state (correct-stack-cfn applic obj state)))
  477.     ;;(format t "out: ~a~%]" state )
  478.     state)))
  479.  
  480.   ;; self call or labels call.
  481.  
  482.   (defun apply-lexical-function (obj applic tail state)
  483.     (let ((branch-lab (read-init-label (defn-body (function-fn obj))) state))
  484.       (if tail
  485.       (do-code-sequence
  486.        ;; Should blast the function call position...
  487.        (list (lambda (state)
  488.            (push-args (applic-args applic) obj state))
  489.          (lambda (state)
  490.            (grab-environment applic
  491.                      (defn-body (function-fn obj))
  492.                      state))
  493.          (lambda (state)
  494.            (do-slide (stack-depth (state-stack state))
  495.                  (+ (actual-args applic obj) 1)
  496.                  state))
  497.          (lambda (state)
  498.            (do-branch branch-lab state)))
  499.        state)
  500.     (let ((ret-lab (make-label nil)))
  501.       (let* ((state (do-push-label ret-lab state))
  502.          (state (do-push-static nil state)) ;; XXX should be an env description{or something}
  503.          (state (push-args (applic-args applic) obj state))
  504.          (state (grab-environment applic
  505.                       (defn-body (function-fn obj))
  506.                       state))
  507.          (state (do-branch branch-lab state))
  508.          (state (do-add-label ret-lab state))
  509.          (state (correct-stack applic obj state)))
  510.         state)))))
  511.  
  512.   (defun apply-inline-function (obj applic tail state)
  513.     (if tail
  514.     (cond ((and (consp (function-prop obj 'code))
  515.             (eq (car (function-prop obj 'code)) 'returning))
  516.            (let* ((state (push-args (applic-args applic) obj state))
  517.               (state (do-slide (stack-depth (state-stack state))
  518.                        (actual-args applic obj)
  519.                        state))
  520.               (state (do-inline-code (function-prop obj 'code)
  521.                          (actual-args applic obj)
  522.                          state)))
  523.          state))
  524.           (t (do-code-sequence
  525.           (list (lambda (state)
  526.               (push-args (applic-args applic) obj state))
  527.             (lambda (state)
  528.               (do-slide (stack-depth (state-stack state))
  529.                     (actual-args applic obj)
  530.                     state))
  531.             (lambda (state)
  532.               (do-inline-code (function-prop obj 'code)
  533.                       (actual-args applic obj)
  534.                       state))
  535.             (lambda (state)
  536.               (do-return state)))
  537.           state)))
  538.       (let* ((state (push-args (applic-args applic) obj state))
  539.          (state (do-inline-code (function-prop obj 'code)
  540.                     (actual-args applic obj)
  541.                     state)))
  542.     state)))
  543.  
  544.   (defun apply-special-function (obj applic tail state)
  545.     ;;(format t "In special: [~a] ~a~%" obj applic)
  546.     (cond ((eq (special-term-name (function-fn obj)) 'call-next-method-internal)
  547.        (if tail
  548.            (let* ((state  (tail-prepare-args obj applic state))
  549.               (state (do-apply-methods (mk-calltype applic obj)
  550.                            state)))
  551.          state)
  552.          (let* ((ret-lab (make-label nil))
  553.             (state (std-prepare-args obj applic state ret-lab))
  554.             (state (do-apply-methods (mk-calltype applic obj) state))
  555.             (state (do-add-label ret-lab state))
  556.             (state (correct-stack applic obj state)))
  557.            state)))
  558.       ((eq (special-term-name (function-fn obj)) 'inline-fn)
  559.        (apply-inline-function obj applic tail state))
  560.       (t (error "Unknown special" Compile-Time-Error 'msg "Bad special: ~a~%"
  561.             'values (list obj)))))
  562.  
  563.  
  564.  
  565.   (progn
  566.     ((setter find-app-fn) 'lexical apply-lexical-function)
  567.     ((setter find-app-fn) 'local apply-local-function)
  568.     ((setter find-app-fn) 'bytefunction apply-nonlocal-function)
  569.     ((setter find-app-fn) 'inline apply-inline-function)
  570.     ((setter find-app-fn) 'unknown apply-unknown-function)
  571.     ((setter find-app-fn) 'function apply-c-function)
  572.     ((setter find-app-fn) 'special apply-special-function)
  573.     )
  574.   ;; move the arguments onto the stack, together with a
  575.   ;; label in the right (TM) place, and move the function
  576.   ;; to the top
  577.   (defun std-prepare-args (obj applic state ret-lab)
  578.     (do-code-sequence
  579.      (list (lambda (state)
  580.          (do-push-label ret-lab state))
  581.        (lambda (state)
  582.          (code-gen (applic-fun applic) state))
  583.        (lambda (state)
  584.          (push-args (applic-args applic) obj state))
  585.        (lambda (state)
  586.          (do-stack-ref (actual-args applic obj) state)))
  587.      state))
  588.  
  589.  
  590.   ;; Push the arguments on to the stack, and slide down to a position where
  591.   ;; the tail call can be done
  592.  
  593.   (defun tail-prepare-args (obj applic state)
  594.     (do-code-sequence
  595.      (list (lambda (state)
  596.          (code-gen (applic-fun applic) state))
  597.        (lambda (state)
  598.          (push-args (applic-args applic) obj state))
  599.        (lambda (state)
  600.          (do-stack-ref (actual-args applic obj) state))
  601.        (lambda (state)
  602.          (do-slide (stack-depth (state-stack state))
  603.                (+ (actual-args applic obj) 1)
  604.                state))
  605.        (lambda (state)
  606.          (blast-current-fn state)))
  607.      state))
  608.  
  609.   ;; this way 'cos I want to see what the code looks like...
  610.   (defun blast-current-fn (state)
  611.     (let* ((state (do-stack-ref 0 state)))
  612.       (do-set-stack-ref (stack-depth (state-stack state)) state)))
  613.  
  614.   (defun correct-stack (applic obj state)
  615.     (modify-compiler-state
  616.      state
  617.      'state-stack
  618.      (let ((stack (state-stack state)))
  619.        (stack-push (stack-pop stack
  620.                   (+ (actual-args applic obj) 4))
  621.                (make-stack-val)))))
  622.  
  623.   (defun correct-stack-cfn (applic obj state)
  624.     (modify-compiler-state
  625.      state
  626.      'state-stack
  627.      (let ((stack (state-stack state)))
  628.        (stack-push (stack-pop stack
  629.                   (+ (actual-args applic obj) 1))
  630.                (make-stack-val)))))
  631.  
  632.   (defun push-args (args obj state)
  633.     ;; should do nary-check here
  634.     (if (car (function-nargs obj))
  635.     (push-nary-args (cdr (function-nargs obj)) args state)
  636.       (fold (lambda (arg state)
  637.           (let ((xx (code-gen arg state)))
  638.         xx))
  639.         args
  640.         state)))
  641.  
  642.   (defun push-nary-args (nargs args state)
  643.     ;; keep pushing till we get to optionals
  644.     (if (= nargs 1)
  645.     (push-optional-args args state)
  646.       (push-nary-args (- nargs 1) (cdr args)
  647.               (code-gen (car args) state))))
  648.  
  649.   (defun push-optional-args (args state)
  650.     (if (null args)
  651.     (do-push-static nil state)
  652.       (do-code-sequence
  653.        (list (lambda (state)
  654.            (code-gen (car args) state))
  655.          (lambda (state)
  656.            (do-push-static nil state))
  657.          (lambda (state)
  658.            (do-cons state))
  659.          (lambda (state)
  660.            (do-stack-ref 0 state))
  661.          (lambda (state)
  662.            (push-remaining-args (cdr args) state)))
  663.        state)))
  664.  
  665.   (defun push-remaining-args (args state)
  666.     (if (null args)
  667.     (do-pop 1 state)
  668.       (push-remaining-args (cdr args)
  669.                (do-code-sequence
  670.                 (list (lambda (state)
  671.                     (code-gen (car args) state))
  672.                   (lambda (state)
  673.                     (do-push-static nil state))
  674.                   (lambda (state)
  675.                     (do-cons state))
  676.                   (lambda (state)
  677.                     (do-setter-cdr state)))
  678.                 state))))
  679.  
  680.   ;; actual number of args pushed:
  681.   (defun actual-args (applic obj)
  682.     (if (car (function-nargs obj))
  683.     (cdr (function-nargs obj))
  684.       (list-length (applic-args applic))))
  685.  
  686.   (defun mk-calltype (applic obj)
  687.     (if (car (function-nargs obj))
  688.     (- (cdr (function-nargs obj)))
  689.       (list-length (applic-args applic))))
  690.  
  691.   (defun grab-environment (applic fn state)
  692.     (if (not (lambda-closed-p fn))
  693.     (do-push-static nil state)
  694.       (let ((env (stacked-lambda-env (enclosing-lambda fn)))
  695.         (enc-lambda (enclosing-lambda applic)))
  696.     ;;(format t "(Grab env: ~a ~a ~a~%" applic env state)
  697.     (let ((local-env (stacked-lambda-env enc-lambda)))
  698.       (if (= (env-object-size env) 0)
  699.           (do-push-static nil state)
  700.         (let ((state (fetch-environment enc-lambda state)))
  701.           (if (eq env local-env)
  702.           state
  703.         (do-pop-env (find-env-depth local-env env) state))))))))
  704.  
  705.  
  706.   (defun push-local-env (fn state)
  707.     (let ((env (stacked-lambda-env fn)))
  708.       (if (= (env-object-size env) 0)
  709.       (let* ((state (do-pop 1 state))
  710.          (state (do-push-static nil state)))
  711.         state)
  712.     (do-slot-ref 0 state))))
  713.  
  714.   ;; Calling sequence...
  715.   ;; args are in the order
  716.   ;; [fn]/[mds] [return address] a0 a1 a2 a3 <env> [fn]
  717.  
  718.   ;; code gen for lambda should assume args on stack,
  719.   ;; and that, if nec. an env will be placed on the stack
  720.   ;; by its own calling routine.
  721.  
  722.   ;; When a fn completes, its stack should be contain it's return value
  723.   ;; Compiling tail calls:
  724.   ;; should be just a jump to the relavant routine,
  725.   ;; preparing the arguments as low on the stack as possible
  726.  
  727.   ;; if inline,
  728.   ;; args should (hem hem) be OK
  729.   ;; just insert the relavant code
  730.   ;; o/w create new code-vector and compile into that.
  731.   ;;   add code to initialise the function
  732.   ;; exit: restore the stack to the initial state
  733.  
  734.   (defmethod generic-code-gen ((lam lambda-term) state)
  735.     ;;(format t "~%(In Lambda: ")
  736.     ;;(format t "State: ~a~%" state)
  737.     (let ((new-state (code-gen (lambda-body lam)
  738.                    ;; does env-construction, etc
  739.                    (add-entry-code lam
  740.                            (new-code-state lam state)))))
  741.       (let ((next-state (modify-compiler-state
  742.              state
  743.              'state-statics (state-statics new-state)
  744.              'state-code
  745.              (add-code-vectors (cons (reify-code-stream new-state)
  746.                          (state-code new-state))
  747.                        state))))
  748.     ;; bung lambda onto stack
  749.     (let ((state (do-allocate-function lam
  750.                        next-state
  751.                        )))
  752.       (let ((aa (if (term-tail-call lam)
  753.             (add-tidy-code (enclosing-lambda lam) state)
  754.               state)))
  755.         ;;(format t "Final state: ~a)~%" aa)
  756.         aa)))))
  757.  
  758.  
  759.   (defun new-code-state (lam state)
  760.     ;;(format t "(New state: ")
  761.     (let ((stack (fold (lambda (arg stack)
  762.              (stack-push stack arg))
  763.                (lambda-ids lam)
  764.                (make-stack)))
  765.       (out-stream (make-new-code-stream)))
  766.       (modify-compiler-state state
  767.                  ;; should only push env if we have one
  768.                  'state-stack (stack-push stack (stacked-lambda-env (enclosing-lambda lam)))
  769.                  'state-stream out-stream
  770.                  'state-statics (state-statics state)
  771.                  'state-code (make-code-list))))
  772.  
  773.   ;; add the stuff the program will have to do on entry
  774.   (defun add-entry-code (lam state)
  775.     (let* ((env (lambda-env lam))
  776.        (init-label (read-init-label lam))
  777.        (new-state (do-code-sequence
  778.                (cons (lambda (state)
  779.                    (do-add-label init-label state))
  780.                  (if (> (env-object-size env) 0)
  781.                  (list (lambda (state)
  782.                      (do-alloc-env env state)))
  783.                    ()))
  784.                state)))
  785.       ;;(format t "Env: ~a~%" env)
  786.       (if t ;;(lambda-closed-p lam)
  787.       ;; copy things into the closure
  788.       (fold (lambda (bind state)
  789.           (if (binding-closed bind)
  790.               (add-to-env bind state)
  791.             state))
  792.         (lambda-ids lam)
  793.         new-state)
  794.     ;; throw away parent environment
  795.     (do-pop 1 state))))
  796.  
  797.   ;; Get the entry point right !
  798.   (defun read-init-label (lam)
  799.     (or (lambda-init-label lam)
  800.     (let ((newlab (make-label nil)))
  801.       ((setter lambda-init-label) lam newlab)
  802.       newlab)))
  803.  
  804.   (defun add-to-env (bind state)
  805.     (let ((posn (scanq-stack (state-stack state)
  806.                  bind)))
  807.       (do-code-sequence
  808.        (list (lambda (state)
  809.            (do-stack-ref posn state))
  810.          (lambda (state)
  811.            (do-setter-env-ref 0 (binding-posn bind) state)))
  812.        state)))
  813.  
  814.   ;; Lazily calculate environments
  815.   (defun lambda-env (lam)
  816.     (let ((e (real-lambda-env lam)))
  817.       (or e
  818.       (let ((xx (make-lambda-environment lam)))
  819.         ((setter real-lambda-env) lam xx)
  820.         xx))))
  821.  
  822.   ;; make an environment...
  823.   (defun make-lambda-environment (lam)
  824.     (let ((closed-bindings (collect allocable-defn-p (find-closure lam))))
  825.       ;; enumerate them
  826.       (fold (lambda (bind n)
  827.           ((setter binding-posn) bind n)
  828.           (+ n 1))
  829.         closed-bindings
  830.         0)
  831.       (make-env-object (list-length closed-bindings)
  832.                (convert closed-bindings <vector>)
  833.                (enclosing-env lam))))
  834.  
  835.   (defgeneric allocable-defn-p (defn))
  836.   (defmethod allocable-defn-p ((x lambda-id))
  837.     t)
  838.  
  839.   (defmethod allocable-defn-p ((defn definition))
  840.     (if (binding-as-arg defn)
  841.     t
  842.       (not (inhibit-alloc (defn-body defn)))))
  843.  
  844.   (defun binding-needed-p (defn)
  845.     (and (binding-used defn)
  846.      (not (lambda-inhibit-alloc (defn-body defn)))))
  847.  
  848.   ;; discover what needs to be placed in the environment
  849.  
  850.   (defgeneric find-closure (obj)
  851.     methods ((((lam lambda-term))
  852.           (append (collect (lambda (x) (if (binding-closed x) x nil))
  853.                    (lambda-ids lam))
  854.               (get-internal-closed-bindings (lambda-body lam))))
  855.          (((mod module-block))
  856.           (get-internal-closed-bindings (module-body mod)))))
  857.  
  858.   (defgeneric enclosing-env (obj)
  859.     methods ((((lam lambda-term))
  860.           (lambda-env (enclosing-lambda lam)))
  861.          (((mod module-block))
  862.           nil)))
  863.  
  864.   ;; finally [This is called in many places]
  865.   (defun add-tidy-code (lam state)
  866.     (do-code-sequence
  867.      (list (lambda (state)
  868.          (do-slide (stack-depth (state-stack state)) 1 state))
  869.        (lambda (state)
  870.          (do-dead-code (do-return state))))
  871.      state))
  872.  
  873.   ;; other side of the fence
  874.   (defgeneric allocate-closure-code (lam argcode state))
  875.  
  876.   (defun do-allocate-function (lam state)
  877.     ;;(format t "Alloc: ~a ~a~%" (lambda-inhibit-alloc lam) lam)
  878.     (if (lambda-inhibit-alloc lam)
  879.     (progn ;;(format t "Inhibit: ~a~%" lam)
  880.            (do-push-static nil state))
  881.       (let ((s1 (do-push-label (read-init-label lam)
  882.                    state))
  883.         (init-ilist (if t;; do we need to shove an env on the stack?
  884.                 (list (lambda (state)
  885.                     (fetch-environment (enclosing-lambda lam) state))
  886.                   )
  887.               (list (lambda (state)
  888.                   (do-push-static nil state))))))
  889.     (allocate-closure-code lam 
  890.                    (lambda-nargs lam)
  891.                    (do-code-sequence init-ilist s1))
  892.     )))
  893.  
  894.   (defun fetch-environment (lam state)
  895.     ;; Should find the env of this function or block...
  896.     ;; and place it on the top of the stack (maybe registerise if we're
  897.     ;; feeling keen)
  898.     ;;(format t "(Fetch env: ~a ~a" lam state)
  899.     ;;(print-props lam)
  900.     (let ((posn (scanq-stack (state-stack state) (stacked-lambda-env lam))))
  901.       ;;(format t "at ~a" posn)
  902.       (do-stack-ref posn state)
  903.       ))
  904.  
  905.   (defun stacked-lambda-env (lam)
  906.     (cond ((module-p lam) (lambda-env lam))
  907.       ((> (env-object-size (lambda-env lam)) 0)
  908.        (lambda-env lam))
  909.       (t (stacked-lambda-env (enclosing-lambda lam)))))
  910.  
  911.   (defmethod allocate-closure-code ((x lambda-term) argcode state)
  912.     (do-allocate-closure argcode nil state))
  913.  
  914.   ;; Macro lambdas...
  915.   ;; do what we normally do, then turn it into a macro
  916.   ;; the last bit is really just for the benifit of
  917.   ;; the interpreter.
  918.  
  919.   (defmethod generic-code-gen ((x macro-lambda-term) state)
  920.     (let ((state (call-next-method)))
  921.       (let ((s1 (do-push-static bc-macro-type state)))
  922.     (do-inline-code '((i-set-type)) 2 s1))))
  923.  
  924.   ;; extended (ie. name/comment-possesing) functions
  925.   
  926.   (defmethod generic-code-gen ((x extended-lambda-term) state)
  927.     (call-next-method))
  928.   
  929.   (defmethod allocate-closure-code ((x extended-lambda-term) argcode state)
  930.     (let ((ref (add-documented-entry (extended-lambda-name x)
  931.                      (extended-lambda-comment x)))
  932.       (state (do-push-static (docs-name) state)))
  933.       (let* ((state (do-push-fixnum ref state))
  934.          (state (do-cons state)))
  935.     (do-allocate-closure argcode t state))))
  936.       
  937.   ;; Blocks...
  938.   ;; rely on code-gen-for-decl.
  939.   ;;
  940.   (defgeneric generic-code-gen-for-decl (decl state))
  941.  
  942.   (defun code-gen-for-decl (decl state)
  943.     ;;(format t "Generating code for decl: ~a~%" decl)
  944.     (generic-code-gen-for-decl decl state))
  945.  
  946.   (defmethod generic-code-gen ((blk block-term) state)
  947.     (let ((state-locs (code-gen-for-decl (block-decl blk) state)))
  948.       (let ((state (cdr state-locs))
  949.         (posns (car state-locs)))
  950.     (let ((state (code-gen (block-body blk) state)))
  951.       (if (term-tail-call blk)
  952.           state
  953.         (fold delete-decl posns state))))))
  954.  
  955.   (defun delete-decl (posn state)
  956.     (let ((offset (- (stack-depth (state-stack state)) posn)))
  957.       (do-slide (+ offset 1) offset state)))
  958.  
  959.   ;;   for normal lets, stuff each arg onto the stack in turn
  960.   ;;   recursive lets: allocate space for the objects all at once
  961.  
  962.   (defmethod generic-code-gen-for-decl ((decl and-decl) state)
  963.     ;; over simple. I could be real cunning here.
  964.     (fold (lambda (decl state)
  965.         (let ((aa (code-gen-for-decl decl (cdr state))))
  966.           (cons (append (car aa) (car state))
  967.             (cdr aa))))
  968.       (and-decl-decls decl)
  969.       (cons nil state)))
  970.  
  971.   (defmethod generic-code-gen-for-decl ((rec rec-decl) state)
  972.     (code-gen-for-decl (rec-decl-decl rec)
  973.                state))
  974.  
  975.   (defmethod generic-code-gen-for-decl ((defn definition) state)
  976.     ;; XX should map this down as a post-pass to annotate
  977.     (let ((state (code-gen (defn-body defn) state)))
  978.       (if (not (binding-needed-p defn))
  979.       (let ((state (do-pop 1 state)))
  980.         ;;(format t "defn: Thrown away: ~a~%" defn)
  981.         (cons nil state))
  982.     (if (binding-closed defn)
  983.         (cons nil (put-defn defn state))
  984.       (let ((state (name-stack-top defn state)))
  985.         (cons (list (stack-depth (state-stack state)))
  986.           state))))))
  987.  
  988.   (defgeneric inhibit-alloc (x)
  989.     methods ((((x lambda-term))
  990.           ((setter lambda-inhibit-alloc) x t)
  991.           t
  992.           )
  993.          (((x syntax-obj))
  994.           nil)))
  995.  
  996.   (defun put-defn (defn state)
  997.     (let ((posn (binding-posn defn)))
  998.       (do-code-sequence
  999.        (list (lambda (state)
  1000.            (fetch-environment (enclosing-lambda defn) state))
  1001.          do-swap
  1002.          (lambda (state)
  1003.            (do-setter-env-ref 0 posn state))
  1004.          (lambda (state)
  1005.            (do-pop 1 state)))
  1006.        state)))
  1007.  
  1008.   (defmethod generic-code-gen-for-decl ((defn module-definition) state)
  1009.     (format t "~a " (defn-ide defn))
  1010.     (cons nil (do-global-set (external-name defn) (code-gen (defn-body defn) state))))
  1011.  
  1012.  
  1013.   (defun name-stack-top (name state)
  1014.     ;;(format t "Name tos: ~a ~a~%" name state)
  1015.     (modify-compiler-state
  1016.      state
  1017.      'state-stack
  1018.      (stack-push (stack-pop (state-stack state) 1)
  1019.          name)))
  1020.  
  1021.  
  1022.   ;; Statics.
  1023.  
  1024.   (defmethod generic-code-gen ((x literal-term) state)
  1025.     (let ((state (if (eq (class-of (literal-content x)) <integer>)
  1026.              (do-push-fixnum (literal-content x) state)
  1027.            (do-push-static (literal-content x) state))))
  1028.       (if (term-tail-call x)
  1029.       (add-tidy-code (enclosing-lambda x) state)
  1030.     state)))
  1031.  
  1032.  
  1033.   ;; Exports (we just ignore them)
  1034.   (defmethod generic-code-gen ((x export-spec) state)
  1035.     (do-push-static nil state))
  1036.  
  1037.  
  1038.    ;; end module
  1039.   )
  1040.  
  1041. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1042. ;; OLD function call methods....
  1043. ;;
  1044. ;; Nasty
  1045.  
  1046. ;;XXX  (defmethod generic-code-gen ((applic applic-term) state)
  1047. ;;XXX    (let ((obj (find-fn (applic-fun applic)))
  1048. ;;XXX      (lab (make-label state))
  1049. ;;XXX      (tail-flag (term-tail-call applic)))
  1050. ;;XXX      (check-arguments applic obj)
  1051. ;;XXX      (do-callbacks (function-fn obj) applic)
  1052. ;;XXX      ;;(format t "*Found function: ~a-->~a~%" (applic-fun applic) obj)
  1053. ;;XXX      ;; make the code for the call
  1054. ;;XXX      (if tail-flag
  1055. ;;XXX      (add-tail-call-code applic lab obj state)
  1056. ;;XXX    (add-std-call-code applic lab obj state))))
  1057. ;;XXX
  1058. ;;XXX  ;; paranoia
  1059. ;;XXX  (defun check-arguments (applic obj)
  1060. ;;XXX    (let ((nargs (list-length (applic-args applic)))
  1061. ;;XXX      (reqd-nargs (function-nargs obj)))
  1062. ;;XXX      (if (or (eq (function-type obj) 'unknown)
  1063. ;;XXX          (= (cdr reqd-nargs) 9999)
  1064. ;;XXX          (= nargs (cdr reqd-nargs))
  1065. ;;XXX          (and (car reqd-nargs)
  1066. ;;XXX           (>= (+ nargs 1) (cdr reqd-nargs))))
  1067. ;;XXX      t
  1068. ;;XXX    (error "Function called with wrong number of args"
  1069. ;;XXX        Compile-Time-Error
  1070. ;;XXX        'values (list reqd-nargs applic)
  1071. ;;XXX        'msg "Function called with wrong number of args (should be ~a): ~%~a~%"))))
  1072. ;;XXX
  1073. ;;XXX  (defconstant find-callback (mk-finder))
  1074. ;;XXX
  1075. ;;XXX  (defgeneric do-callbacks (obj applic)
  1076. ;;XXX    methods ((((x imported-definition) applic)
  1077. ;;XXX          (labels ((do-callback (l)
  1078. ;;XXX                    (cond ((null l) nil)
  1079. ;;XXX                      (t ((find-callback (car l)) applic)
  1080. ;;XXX                         (do-callback (cdr l))))))
  1081. ;;XXX              (do-callback (import-prop-ref x 'callbacks))))
  1082. ;;XXX         (((x syntax-obj) y)
  1083. ;;XXX          nil)))
  1084. ;;XXX
  1085. ;;XXX  ((setter find-callback) 'set-setter
  1086. ;;XXX   (lambda (applic)
  1087. ;;XXX     ;;(format t "set-setter: ~a~%" applic)
  1088. ;;XXX     (if (not (ident-p (cadr (applic-args applic))))
  1089. ;;XXX     nil
  1090. ;;XXX       ((setter obj-setter-decl)
  1091. ;;XXX    (ident-decl (car (applic-args applic)))
  1092. ;;XXX    (ident-decl (cadr (applic-args applic)))))))
  1093. ;;XXX
  1094. ;;XXX  (defun add-std-call-code (applic label obj state)
  1095. ;;XXX    (do-code-sequence
  1096. ;;XXX     (list
  1097. ;;XXX      ;; entry code
  1098. ;;XXX      ;; ho hum
  1099. ;;XXX      (if (eq (function-type obj) 'inline)
  1100. ;;XXX      (lambda (state) state)
  1101. ;;XXX    (lambda (state)
  1102. ;;XXX        (do-push-label label state)))
  1103. ;;XXX      ;; calc fn.
  1104. ;;XXX      (lambda (state)
  1105. ;;XXX    (do-compute-fn applic obj state))
  1106. ;;XXX      ;; args
  1107. ;;XXX      (lambda (state)
  1108. ;;XXX    (push-fn-args (applic-args applic) obj
  1109. ;;XXX              state))
  1110. ;;XXX      (lambda (state)
  1111. ;;XXX    (if (eq (function-type obj) 'inline)
  1112. ;;XXX        state
  1113. ;;XXX      (do-stack-ref (+ (actual-args applic obj) 1) state)))
  1114. ;;XXX      (lambda (state)
  1115. ;;XXX    (do-apply-function applic obj state))
  1116. ;;XXX      (lambda (state)
  1117. ;;XXX    (do-add-label label state))
  1118. ;;XXX      (lambda (state)
  1119. ;;XXX    (modify-compiler-state
  1120. ;;XXX     state
  1121. ;;XXX     'state-stack
  1122. ;;XXX     (compute-final-stack applic obj state))))
  1123. ;;XXX     state))
  1124. ;;XXX
  1125. ;;XXX  (defun add-tail-call-code (applic label obj state)
  1126. ;;XXX    (do-code-sequence
  1127. ;;XXX     (list (lambda (state)
  1128. ;;XXX         (do-compute-fn applic obj state))
  1129. ;;XXX       (lambda (state)
  1130. ;;XXX         (push-fn-args (applic-args applic)
  1131. ;;XXX               obj
  1132. ;;XXX               state))
  1133. ;;XXX       (lambda (state)
  1134. ;;XXX         (do-tidy-tail-call applic obj state))
  1135. ;;XXX       (lambda (state)
  1136. ;;XXX         (do-apply-function applic obj state))
  1137. ;;XXX       )
  1138. ;;XXX     state))
  1139. ;;XXX
  1140. ;;XXX  (defun std-compute-fn (applic obj state)
  1141. ;;XXX    (code-gen (applic-fun applic) state))
  1142. ;;XXX
  1143. ;;XXX  (defun push-args (args obj state)
  1144. ;;XXX    ;; should do nary-check here
  1145. ;;XXX    (if (car (function-nargs obj))
  1146. ;;XXX    (push-nary-args (cdr (function-nargs obj)) args state)
  1147. ;;XXX      (fold (lambda (arg state)
  1148. ;;XXX          (let ((xx (code-gen arg state)))
  1149. ;;XXX        xx))
  1150. ;;XXX        args
  1151. ;;XXX        state)))
  1152. ;;XXX
  1153. ;;XXX  (defun push-nary-args (nargs args state)
  1154. ;;XXX    ;; keep pushing till we get to optionals
  1155. ;;XXX    (if (= nargs 1)
  1156. ;;XXX    (push-optional-args args state)
  1157. ;;XXX      (push-nary-args (- nargs 1) (cdr args)
  1158. ;;XXX              (code-gen (car args) state))))
  1159. ;;XXX
  1160. ;;XXX  (defun push-optional-args (args state)
  1161. ;;XXX    (if (null args)
  1162. ;;XXX    (do-push-static nil state)
  1163. ;;XXX      (do-code-sequence
  1164. ;;XXX       (list (lambda (state)
  1165. ;;XXX           (code-gen (car args) state))
  1166. ;;XXX         (lambda (state)
  1167. ;;XXX           (do-push-static nil state))
  1168. ;;XXX         (lambda (state)
  1169. ;;XXX           (do-cons state))
  1170. ;;XXX         (lambda (state)
  1171. ;;XXX           (do-stack-ref 0 state))
  1172. ;;XXX         (lambda (state)
  1173. ;;XXX           (push-remaining-args (cdr args) state)))
  1174. ;;XXX       state)))
  1175. ;;XXX
  1176. ;;XXX  (defun push-remaining-args (args state)
  1177. ;;XXX    (if (null args)
  1178. ;;XXX    (do-pop 1 state)
  1179. ;;XXX      (push-remaining-args (cdr args)
  1180. ;;XXX               (do-code-sequence
  1181. ;;XXX                (list (lambda (state)
  1182. ;;XXX                    (code-gen (car args) state))
  1183. ;;XXX                  (lambda (state)
  1184. ;;XXX                    (do-push-static nil state))
  1185. ;;XXX                  (lambda (state)
  1186. ;;XXX                    (do-cons state))
  1187. ;;XXX                  (lambda (state)
  1188. ;;XXX                    (do-setter-cdr state)))
  1189. ;;XXX                state))))
  1190. ;;XXX
  1191. ;;XXX  ;; actual args pushed:
  1192. ;;XXX  (defun actual-args (applic obj)
  1193. ;;XXX    (if (car (function-nargs obj))
  1194. ;;XXX    (cdr (function-nargs obj))
  1195. ;;XXX      (list-length (applic-args applic))))
  1196. ;;XXX
  1197. ;;XXX  (defun mk-calltype (applic obj)
  1198. ;;XXX    (if (car (function-nargs obj))
  1199. ;;XXX    (- (cdr (function-nargs obj)))
  1200. ;;XXX      (list-length (applic-args applic))))
  1201. ;;XXX
  1202. ;;XXX  ;; state is: fn args...
  1203. ;;XXX
  1204. ;;XXX  (defun tidy-std-tail-call (applic obj state)
  1205. ;;XXX    (do-code-sequence
  1206. ;;XXX     (list
  1207. ;;XXX      ;; function at the top...
  1208. ;;XXX      (lambda (state)
  1209. ;;XXX    (do-stack-ref (actual-args applic obj) state))
  1210. ;;XXX      (lambda (state)
  1211. ;;XXX    (do-stack-ref 0 state))
  1212. ;;XXX      ;; trash the fn. frame of self
  1213. ;;XXX      (lambda (state)
  1214. ;;XXX    (do-set-stack-ref (+ (stack-depth (state-stack state)) 1) state))
  1215. ;;XXX      ;; slide down
  1216. ;;XXX      (lambda (state)
  1217. ;;XXX    (do-slide (stack-depth (state-stack state))
  1218. ;;XXX          (+ (actual-args applic obj) 1)
  1219. ;;XXX          state)))
  1220. ;;XXX      state))
  1221. ;;XXX
  1222. ;;XXX  (defun apply-bytefunction (applic obj state)
  1223. ;;XXX    (do-apply-bvf (mk-calltype applic obj) state))
  1224. ;;XXX
  1225. ;;XXX  (defun apply-any (applic obj state)
  1226. ;;XXX    (do-apply-any (mk-calltype applic obj) state))
  1227. ;;XXX
  1228. ;;XXX  (defun apply-methods (applic obj state)
  1229. ;;XXX    ;;(format t "Apply methods: ~a~%" state)
  1230. ;;XXX    (do-apply-methods (mk-calltype applic obj)
  1231. ;;XXX              state))
  1232. ;;XXX
  1233. ;;XXX  (defun compute-std-final-stack (applic obj state)
  1234. ;;XXX    (let ((stack (state-stack state)))
  1235. ;;XXX      (stack-push (stack-pop stack
  1236. ;;XXX                 (+ (actual-args applic obj) 4))
  1237. ;;XXX          (make-stack-val))))
  1238. ;;XXX
  1239. ;;XXX  (defun apply-inline-call (applic obj state)
  1240. ;;XXX    (let ((state (do-inline-code (import-prop-ref (function-fn obj) 'code)
  1241. ;;XXX                 (actual-args applic obj)
  1242. ;;XXX                 state)))
  1243. ;;XXX      (if (term-tail-call applic)
  1244. ;;XXX      (add-tidy-code (enclosing-lambda applic) state)
  1245. ;;XXX    state)))
  1246. ;;XXX
  1247. ;;XXX  ;; slide down+ return...
  1248. ;;XXX  (defun tidy-inline-call (applic obj state)
  1249. ;;XXX    (do-slide (stack-depth (state-stack state))
  1250. ;;XXX          (actual-args applic obj)
  1251. ;;XXX          state))
  1252. ;;XXX
  1253. ;;XXX  ;; for the time being...
  1254. ;;XXX  (defun compute-no-function (applic obj state)
  1255. ;;XXX    (code-gen (applic-fun applic) state))
  1256. ;;XXX
  1257. ;;XXX  (defun apply-local-fn (applic obj state)
  1258. ;;XXX    (do-code-sequence
  1259. ;;XXX     ;; XXX 0 is the posn of the environment of a function
  1260. ;;XXX     ;; unfortunately, we ain't calculated its env yet, so just push it.
  1261. ;;XXX     (list (lambda (state)
  1262. ;;XXX         (do-slot-ref 0 state))
  1263. ;;XXX       (lambda (state)
  1264. ;;XXX         (do-branch (read-init-label (car obj)) state)))
  1265. ;;XXX     state))
  1266. ;;XXX
  1267. ;;XXX  ;; Apply-self: call by shoving env
  1268. ;;XXX  (defun apply-self (applic obj state)
  1269. ;;XXX    (let ((s1 (stack-enclosing-env applic state)))
  1270. ;;XXX      (do-branch (read-init-label (car obj)) s1)))
  1271. ;;XXX
  1272. ;;XXX  (defun stack-enclosing-env (applic state)
  1273. ;;XXX    ;;(print (list applic state))
  1274. ;;XXX    (let ((enc (enclosing-lambda applic)))
  1275. ;;XXX      (let ((env (stacked-lambda-env enc))
  1276. ;;XXX        ;; for other locals, could use (enclosing-lambda (car obj)).
  1277. ;;XXX        (e2 (stacked-lambda-env (enclosing-lambda enc))))
  1278. ;;XXX    ;; XXX really a check for non-existent module-environment
  1279. ;;XXX    (if (= (env-object-size e2) 0)
  1280. ;;XXX        (do-push-static nil (do-pop 1 state))
  1281. ;;XXX      (do-code-sequence
  1282. ;;XXX       (if (term-tail-call applic)
  1283. ;;XXX           (list (lambda (state)
  1284. ;;XXX               (name-stack-top env (do-slot-ref 0 state))))
  1285. ;;XXX         (cons (lambda (state)
  1286. ;;XXX             (fetch-environment enc (do-pop 1 state)))
  1287. ;;XXX           (if (eq env e2) nil
  1288. ;;XXX             (list
  1289. ;;XXX              (lambda (state)
  1290. ;;XXX            (do-pop-env (find-env-depth env e2) state))))))
  1291. ;;XXX       state)))))
  1292. ;;XXX
  1293. ;;XXX
  1294. ;;XXX
  1295. ;;XXX  (defconstant find-fns (mk-finder))
  1296. ;;XXX
  1297. ;;XXX  (defun find-fn-computer (obj)
  1298. ;;XXX    (car (find-fns (function-type obj))))
  1299. ;;XXX
  1300. ;;XXX  (defun find-apply-fn (obj)
  1301. ;;XXX    (cadr (find-fns (function-type obj))))
  1302. ;;XXX
  1303. ;;XXX  (defun find-tidy-fn (obj)
  1304. ;;XXX    (caddr (find-fns (function-type obj))))
  1305. ;;XXX
  1306. ;;XXX  (defun find-arg-pusher (obj)
  1307. ;;XXX    (nth 3 (find-fns (function-type obj))))
  1308. ;;XXX
  1309. ;;XXX  (defun find-stack-computer (obj)
  1310. ;;XXX    (nth 4 (find-fns (function-type obj))))
  1311. ;;XXX
  1312. ;;XXX  (defun do-compute-fn (applic obj state)
  1313. ;;XXX    ((find-fn-computer obj) applic obj state))
  1314. ;;XXX
  1315. ;;XXX  (defun push-fn-args (applic obj state)
  1316. ;;XXX    ((find-arg-pusher obj) applic obj state))
  1317. ;;XXX
  1318. ;;XXX  ;; fns called by applic generators
  1319. ;;XXX  (defun compute-final-stack (applic obj state)
  1320. ;;XXX    ((find-stack-computer obj) applic obj state))
  1321. ;;XXX
  1322. ;;XXX  (defun do-tidy-tail-call (applic obj state)
  1323. ;;XXX    ((find-tidy-fn obj) applic obj state))
  1324. ;;XXX
  1325. ;;XXX  (defun do-apply-function (applic obj state)
  1326. ;;XXX    ((find-apply-fn obj) applic obj state))
  1327. ;;XXX
  1328. ;;XXX  ;; description of the calling procedures
  1329. ;;XXX  ((setter find-fns) 'bytefunction
  1330. ;;XXX   (list std-compute-fn
  1331. ;;XXX     apply-bytefunction tidy-std-tail-call
  1332. ;;XXX     push-args  compute-std-final-stack))
  1333. ;;XXX
  1334. ;;XXX  ((setter find-fns) 'unknown
  1335. ;;XXX   (list std-compute-fn
  1336. ;;XXX     apply-any tidy-std-tail-call
  1337. ;;XXX     push-args  compute-std-final-stack))
  1338. ;;XXX
  1339. ;;XXX  ((setter find-fns) 'function
  1340. ;;XXX   (list std-compute-fn
  1341. ;;XXX     apply-any tidy-std-tail-call
  1342. ;;XXX         push-args compute-std-final-stack))
  1343. ;;XXX
  1344. ;;XXX  ((setter find-fns) 'inline
  1345. ;;XXX   (list (lambda (applic obj state) state)
  1346. ;;XXX     apply-inline-call
  1347. ;;XXX     tidy-inline-call
  1348. ;;XXX     push-args
  1349. ;;XXX     (lambda (applic obj x) (state-stack x))))
  1350. ;;XXX
  1351. ;;XXX  ((setter find-fns) 'cnm
  1352. ;;XXX   (list std-compute-fn
  1353. ;;XXX     apply-methods
  1354. ;;XXX     tidy-std-tail-call
  1355. ;;XXX     push-args
  1356. ;;XXX     compute-std-final-stack))
  1357. ;;XXX
  1358. ;;XXX  ((setter find-fns) 'local-defun
  1359. ;;XXX   (list compute-no-function
  1360. ;;XXX     apply-local-fn
  1361. ;;XXX     tidy-std-tail-call
  1362. ;;XXX     push-args
  1363. ;;XXX     compute-std-final-stack))
  1364. ;;XXX
  1365. ;;XXX  ((setter find-fns) 'self-call
  1366. ;;XXX   (list compute-no-function
  1367. ;;XXX     apply-self
  1368. ;;XXX     tidy-std-tail-call
  1369. ;;XXX     push-args
  1370. ;;XXX     compute-std-final-stack))
  1371. ;;XXX
  1372. ;;XXX
  1373.